perm filename DISTO.F4[DRW,LCS] blob
sn#525288 filedate 1980-07-23 generic text, type T, neo UTF8
DIMENSION I(4),II(4),JIN(3,14000)
COMMON/D/ JD(4000),ID(3,40000) /JJJJ/JP,KP,XS,YS
COMMON NMOUT/OUTER/LFT,RT,TOP,BOT
INTEGER X1,X2,Y1,Y2,LFT,RT,TOP,BOT
EQUIVALENCE (X1,I(2)),(Y1,I(3)),(X2,II(2)),(Y2,II(3)),(J,I(4))
1,(JJ,II(4))
DATA IFIRST/0/
1 FORMAT(' TYPE INPUT NAME '$)
2 FORMAT(' TYPE OUTPUT NAME '$)
3 FORMAT(A5)
4 FORMAT(' TYPE FUNC NAME '$)
6 FORMAT(4I)
81 FORMAT(2I,2F)
66 FORMAT(5X,4I)
80 FORMAT(' X POS, Y POS, X SIZE, Y SIZE '$)
IF(IFIRST)GO TO 95
C DOESN'T READ DATA FILE AFTER 1ST TIME.
IFIRST=-1
TOP=-9999
BOT=-TOP
LFT=BOT
RT=TOP
TYPE 1
ACCEPT 3,NMIN
C TYPE 2
C ACCEPT 3,NMOUT
CALL IFILE(21,NMIN)
NNN=1
C82 READ(21,6,END=95)NNN,(JIN(K,NNN),K=1,3)
82 READ(21,6,END=95)NN,(JIN(K,NNN),K=1,3)
NNN=NNN+1
GO TO 82
C CALL OFILE(22,NMOUT)
95 NN=0
NX=0
NNN=NNN-1
TYPE 80
ACCEPT 81,JP,KP,XS,YS
IF(XS.EQ.0)XS=1
IF(YS.EQ.0)YS=1
5 CALL SHFT(I,JIN,NX)
C5 READ(21,6)I
C X1=X1*XS+.5
C Y1=Y1*YS+.5
C TYPE 66,I
7 IF(NX.EQ.NNN)GO TO 100
CALL SHFT(II,JIN,NX)
C7 READ(21,6,END=100)II
C X2=X2*XS+.5
C Y2=Y2*YS+.5
C TYPE 66,II
99 IF(JJ.EQ.0)GO TO 13
98 CALL NNO(NN)
I(1)=NN
ID(1,NN)=X1
ID(2,NN)=Y1
ID(3,NN)=J
C WRITE(22,6)I
C TYPE 6,I
GO TO 8
13 M=1
K=X2-X1
KK=K
IF(K.GE.0)GO TO 10
M=-1
KK=-K
10 L=Y2-Y1
MM=1
LL=L
IF(L.GE.0)GO TO 11
MM=-1
LL=-L
11 IF(LL.GT.KK)GO TO 12
IF(KK.LT.2)GO TO 98
DO 9 N=X1,X2-M,M
A=N-X1
B=K
NY=Y1+L*A/B+.5
CALL NNO(NN)
C TYPE 6,NN,N,NY,J
ID(1,NN)=N
ID(2,NN)=NY
ID(3,NN)=J
C WRITE(22,6)NN,N,NY,J
9 J=0
8 X1=X2
Y1=Y2
J=JJ
GO TO 7
12 IF(LL.LT.2)GO TO 98
DO 19 N=Y1,Y2-MM,MM
A=N-Y1
B=L
NY=X1+K*A/B+.5
CALL NNO(NN)
C TYPE 6,NN,NY,N,J
C WRITE(22,6)NN,NY,N,J
ID(1,NN)=NY
ID(2,NN)=N
ID(3,NN)=J
19 J=0
GO TO 8
C100 WRITE(22,6)II
100 CALL NNO(NN)
DO 96 K=1,3
96 ID(K,NN)=II(K+1)
ID(3,NN+1)=-1
CALL DSTO(LFT,RT)
101 CALL DPY
N=0
102 N=N+1
J=ID(3,N)
IF(J.GT.1)GO TO 102
C SKIP UNNEEDED LINES.
IF(J)GO TO 104
WRITE(22,103)N,(ID(K,N),K=1,3)
GO TO 102
104 END FILE 22
GO TO 95
103 FORMAT(4I6)
END